home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Thomas / MacGambit⁄Thomas / MacGambit⁄Thomas Sources / Thomas 1.1 sources / new-repl.scm < prev    next >
Encoding:
Text File  |  1995-03-15  |  6.0 KB  |  176 lines  |  [TEXT/gamI]
  1. (##include "header.scm alias")
  2. ; Read eval print loop
  3. ;;;the #$#@)&# compiler doesn't like default args
  4. ;(define (thomas-rep (in ##stdin) (out ##stdout) (prompt2 "? ") (prompt1 ""))
  5. ;  (##call-with-current-continuation
  6. ;    (lambda (cont) (thomas-read-eval-print in out prompt2 prompt1 cont))))
  7.  
  8. (define (thomas-rep in out prompt2 prompt1)
  9.   (##call-with-current-continuation
  10.     (lambda (cont) (thomas-read-eval-print in out prompt2 prompt1 cont))))
  11.  
  12. ;(define ##repl-write #f)
  13. ;(set! ##repl-write #f)
  14.  
  15. ;(define ##repl-read #f)
  16. ;(set! ##repl-read #f)
  17.  
  18. (define (thomas-read-eval-print in out prompt2 prompt1 cont)
  19.  
  20.   (define (repl-start subprobs repl-info dyn-bindings)
  21.  
  22.     (define (repl-read)
  23.       (let ((proc ##repl-read))
  24.         (if (##procedure? proc)
  25.           (proc in)
  26.           (##read in))))
  27.  
  28.     (define (repl-write val)
  29.       (let ((proc ##repl-write))
  30.         (if (##procedure? proc)
  31.           (proc val out)
  32.           (begin
  33.             (display val out)
  34.             (##newline out)))))
  35.  
  36.     (define (repl-n n)
  37.       (let loop ((i 0) (s subprobs))
  38.         (if (and (##fixnum.< n i) (##pair? (##cdr s)))
  39.           (loop (##fixnum.- i 1) (##cdr s))
  40.           (let ((f (##car s)))
  41.             (##display-subproblem i f out)
  42.             (repl i s f)))))
  43.  
  44.     (define (cmd-d)
  45.       (let ((l (##cdr (##vector-ref repl-info 3))))
  46.         (if (##pair? l)
  47.           ((##car l) #f)
  48.           (begin
  49.             (##newline out)
  50.             (##write-string "*** ^D again to exit" out)
  51.             (##newline out)
  52.             (if (##eof-object? (##peek-char in))
  53.               (##quit))))))
  54.  
  55.     (define (cmd-t)
  56.       (let loop ((l (##vector-ref repl-info 3)))
  57.         (if (##pair? (##cdr l))
  58.           (loop (##cdr l))
  59.           ((##car l) #f))))
  60.  
  61.     (define (repl pos subprobs* f)
  62.  
  63.       (##call-with-current-continuation
  64.         (lambda (abort)
  65.           (##set-car! (##vector-ref repl-info 3) abort)))
  66.  
  67.       (let loop ()
  68.  
  69.         (##newline out)
  70.         (##display prompt1 out #f)
  71.         (if (##fixnum.< pos 0) (##display pos out #f))
  72.         (##display prompt2 out #f)
  73.  
  74.         (let ((expr (repl-read)))
  75.           (if (##eof-object? expr)
  76.             (begin (cmd-d) (loop))
  77.             (if (and (##pair? expr)
  78.                      (##pair? (##cdr expr))
  79.                      (##null? (##cddr expr))
  80.                      (##eq? (##car expr) 'UNQUOTE))
  81.               (let ((cmd (##cadr expr)))
  82.                 (if (##eof-object? cmd)
  83.                   (begin (cmd-d) (loop))
  84.                   (case cmd
  85.                     ((?) (##cmd-? out) (loop))
  86.                     ((-) (repl-n (##fixnum.- pos 1)))
  87.                     ((+) (repl-n (##fixnum.+ pos 1)))
  88.                     ((b) (##cmd-b pos subprobs* out) (loop))
  89.                     ((i) (##cmd-i f out) (loop))
  90.                     ((y) (##cmd-y f out) (loop))
  91.                     ((l) (##cmd-l f out) (loop))
  92.                     ((t) (cmd-t))
  93.                     ((d) (cmd-d) (loop))
  94.                     ((r) (##display "Return value: " out #f)
  95.                          (let ((expr (repl-read)))
  96.                            (if (##eof-object? expr)
  97.                              ##undef-object
  98.                              (that-special-thomas-thing expr f dyn-bindings))))
  99.                     ((q) (##quit))
  100.                     (else
  101.                      (if (and (##fixnum? cmd) (##fixnum.< cmd 1))
  102.                        (repl-n cmd)
  103.                        (begin
  104.                          (##write-string "Unknown command ," out)
  105.                          (##write cmd out #f)
  106.                          (##newline out)
  107.                          (loop)))))))
  108.               (cond ((eq? expr 'thomas:done) 'thomas:done)
  109.                     (#t
  110.                      (let ((val (that-special-thomas-thing expr f dyn-bindings)))
  111. ;                       (repl-write val)
  112.                        (loop)))))))))
  113.  
  114.     (repl 0 subprobs (##car subprobs)))
  115.  
  116.   (let ((repl-info (##make-vector 4 #f)))
  117.     (let ((prev-info (##dynamic-ref '##REPL-INFO #f))
  118.           (dyn-bindings (##list (##cons '##REPL-INFO repl-info))))
  119.       (##vector-set! repl-info 0 in)
  120.       (##vector-set! repl-info 1 out)
  121.       (##vector-set! repl-info 2
  122.         (if prev-info
  123.           (##fixnum.+ (##vector-ref prev-info 2) 1)
  124.           0))
  125.       (##vector-set! repl-info 3
  126.         (##cons (lambda (x) (##quit))
  127.                 (if prev-info
  128.                   (##vector-ref prev-info 3)
  129.                   '())))
  130.       (##dynamic-bind
  131.         dyn-bindings
  132.         (lambda ()
  133.           (repl-start (##continuation->subproblems cont)
  134.                       repl-info
  135.                       dyn-bindings))))))
  136.  
  137. (define (##debug-repl cont)
  138.   (let ((repl-info (##dynamic-ref '##REPL-INFO #f)))
  139.     (if repl-info
  140.       (thomas-read-eval-print (##vector-ref repl-info 0)
  141.                          (##vector-ref repl-info 1)
  142.                          "? "
  143.                          (##fixnum.+ (##vector-ref repl-info 2) 1)
  144.                          cont)
  145.       (thomas-read-eval-print ##stdin ##stdout ": " 0 cont))))
  146.  
  147. (define (implementation-specific:eval expr f dyn-bindings)
  148.   (##eval-within expr f dyn-bindings))
  149.  
  150. (define (that-special-thomas-thing input f dyn-bindings)
  151.   (compile-expression
  152.    input '!MULTIPLE-VALUES thomas-rep-module-variables
  153.    (lambda (new-vars preamble compiled-output)
  154.      (implementation-specific:eval
  155.       `(BEGIN
  156.          ,@preamble
  157.          (LET* ((!MULTIPLE-VALUES (VECTOR '()))
  158.                 (!RESULT ,compiled-output))
  159.            (IF (EQ? !RESULT !MULTIPLE-VALUES)
  160.              (LET RESULT-LOOP
  161.                ((COUNT 1)
  162.                 (RESULTS (VECTOR-REF !MULTIPLE-VALUES 0)))
  163.                (IF (PAIR? RESULTS)
  164.                  (LET ((RESULT (CAR RESULTS)))
  165.                    (NEWLINE)
  166.                    (DISPLAY ";Value[")(DISPLAY COUNT)
  167.                    (DISPLAY "]: ")(WRITE RESULT)
  168.                    (RESULT-LOOP (+ 1 COUNT) (CDR RESULTS)))
  169.                  (NEWLINE)))
  170.              (BEGIN
  171.                (NEWLINE)
  172.                (DISPLAY ";Value: ")(WRITE !RESULT) (NEWLINE)))))
  173.       f dyn-bindings)
  174.      (set! thomas-rep-module-variables
  175.            (append new-vars thomas-rep-module-variables))
  176.      )))  ; uh oh - no loop?